home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / vm / vm-5.33beta / vm-reply.el < prev    next >
Encoding:
Text File  |  1991-10-16  |  26.5 KB  |  737 lines
  1. ;;; Mailing, forwarding, and replying commands for VM
  2. ;;; Copyright (C) 1989, 1990, 1991 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (defun vm-do-reply (to-all include-text count)
  19.   (save-restriction
  20.     (widen)
  21.     (let ((mail-buffer (current-buffer))
  22.       (mlist (vm-select-marked-or-prefixed-messages count))
  23.       (dir default-directory)
  24.       (message-pointer vm-message-pointer)
  25.       to cc subject mp in-reply-to references tmp tmp2 newsgroups)
  26.       (setq mp mlist)
  27.       (while mp 
  28.     (cond
  29.      ((eq mlist mp)
  30.       (cond ((setq to (vm-get-header-contents (car mp) "Reply-To")))
  31.         ((setq to (vm-get-header-contents (car mp) "From")))
  32.         ((setq to (vm-grok-From_-author (car mp))))
  33.         (t (error "No From: or Reply-To: header in message")))
  34.       (setq subject (vm-get-header-contents (car mp) "Subject")
  35.         in-reply-to (and vm-in-reply-to-format
  36.                  (vm-sprintf 'vm-in-reply-to-format (car mp)))
  37.         in-reply-to (and (not (equal "" in-reply-to)) in-reply-to))
  38.       (and subject vm-reply-subject-prefix
  39.            (let ((case-fold-search t))
  40.          (not
  41.           (equal
  42.            (string-match (regexp-quote vm-reply-subject-prefix)
  43.                  subject)
  44.            0)))
  45.            (setq subject (concat vm-reply-subject-prefix subject))))
  46.      (t (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To"))
  47.            (setq to (concat to "," tmp)))
  48.           ((setq tmp (vm-get-header-contents (car mp) "From"))
  49.            (setq to (concat to "," tmp)))
  50.           ((setq tmp (vm-grok-From_-author (car mp)))
  51.            (setq to (concat to "," tmp)))
  52.           (t (error "No From: or Reply-To: header in message")))))
  53.     (if to-all
  54.         (progn
  55.           (setq tmp (vm-get-header-contents (car mp) "To"))
  56.           (setq tmp2 (vm-get-header-contents (car mp) "Cc"))
  57.           (if tmp
  58.           (if cc
  59.               (setq cc (concat cc "," tmp))
  60.             (setq cc tmp)))
  61.           (if tmp2
  62.           (if cc
  63.               (setq cc (concat cc "," tmp2))
  64.             (setq cc tmp2)))))
  65.     (setq references
  66.           (cons (vm-get-header-contents (car mp) "References")
  67.             (cons (vm-get-header-contents (car mp) "In-reply-to")
  68.               (cons (vm-get-header-contents (car mp) "Message-ID")
  69.                 references))))
  70.     (setq newsgroups
  71.           (cons (or (and to-all (vm-get-header-contents (car mp) "Followup-To"))
  72.             (vm-get-header-contents (car mp) "Newsgroups"))
  73.             newsgroups))
  74.     (setq mp (cdr mp)))
  75.       (if vm-strip-reply-headers
  76.       (let ((mail-use-rfc822 t))
  77.         (and to (setq to (mail-strip-quoted-names to)))
  78.         (and cc (setq cc (mail-strip-quoted-names cc)))))
  79.       (setq to (vm-parse-addresses to)
  80.         cc (vm-parse-addresses cc))
  81.       (if vm-reply-ignored-addresses
  82.       (setq to (vm-strip-ignored-addresses to)
  83.         cc (vm-strip-ignored-addresses cc)))
  84.       (setq to (vm-delete-duplicates to))
  85.       (setq cc (vm-delete-duplicates
  86.         (append (vm-delete-duplicates cc)
  87.             to (copy-sequence to))
  88.         t))
  89.       (and to (setq to (mapconcat 'identity to ",\n    ")))
  90.       (and cc (setq cc (mapconcat 'identity cc ",\n    ")))
  91.       (and (null to) (setq to cc cc nil))
  92.       (setq references (delq nil references)
  93.         references (mapconcat 'identity references " ")
  94.         references (vm-parse references "[^<]*\\(<[^>]+>\\)")
  95.         references (vm-delete-duplicates references)
  96.         references (if references (mapconcat 'identity references "\n\t")))
  97.       (setq newsgroups (delq nil newsgroups)
  98.         newsgroups (mapconcat 'identity newsgroups ",")
  99.         newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
  100.         newsgroups (vm-delete-duplicates newsgroups)
  101.         newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
  102.       (vm-mail-internal
  103.        (format "reply to %s%s" (vm-su-full-name (car mlist))
  104.            (if (cdr mlist) ", ..." ""))
  105.        to subject in-reply-to cc references newsgroups)
  106.       (use-local-map (copy-keymap (current-local-map)))
  107.       (local-set-key "\C-c\C-y" 'vm-yank-message)
  108.       (local-set-key "\C-cy" 'vm-yank-message-other-folder)
  109.       (local-set-key "\C-c\C-s" 'vm-mail-send)
  110.       (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  111.       (local-set-key "\C-c\C-v" vm-mode-map)
  112.       (make-local-variable 'vm-reply-list)
  113.       (setq vm-mail-buffer mail-buffer
  114.         vm-system-state 'replying
  115.         vm-message-pointer message-pointer
  116.         vm-reply-list mlist
  117.         default-directory dir)
  118.       (if include-text
  119.       (save-excursion
  120.         (goto-char (point-min))
  121.         (re-search-forward (concat "^" mail-header-separator "$") nil 0)
  122.         (forward-char 1)
  123.         (while mlist
  124.           (vm-yank-message (car mlist))
  125.           (goto-char (point-max))
  126.           (setq mlist (cdr mlist))))))))
  127.  
  128. (defun vm-strip-ignored-addresses (addresses)
  129.   (setq addresses (copy-sequence addresses))
  130.   (let (re-list list)
  131.     (setq re-list vm-reply-ignored-addresses)
  132.     (while re-list
  133.       (setq addr-list addresses)
  134.       (while addr-list
  135.     (if (string-match (car re-list) (car addr-list))
  136.         (setq addresses (delq (car addr-list) addresses)))
  137.     (setq addr-list (cdr addr-list)))
  138.       (setq re-list (cdr re-list))))
  139.   addresses )
  140.  
  141. (defun vm-mail-yank-default (message)
  142.   (save-excursion
  143.     (delete-region (point) (progn (search-forward "\n\n") (point)))
  144.     (if vm-included-text-attribution-format
  145.     (insert (vm-sprintf 'vm-included-text-attribution-format message)))
  146.     (while (and (re-search-forward "^" nil t) (< (point) (mark)))
  147.       (replace-match vm-included-text-prefix t t))))
  148.  
  149. (defun vm-yank-message-other-folder (folder &optional prefix-argument)
  150.   "Like vm-yank-message except the message is yanked from a folder other
  151. than the one that spawned the current Mail mode buffer.  The name of the
  152. folder is read from the minibuffer.
  153.  
  154. Don't call this function from a program."
  155.   (interactive
  156.    (list
  157.     (let ((dir (if vm-folder-directory
  158.             (expand-file-name vm-folder-directory)
  159.           default-directory)))
  160.       (read-file-name "Yank from folder: " dir nil t))
  161.     current-prefix-arg ))
  162.   (let ((b (current-buffer)) newbuf sumbuf)
  163.     (set-buffer (or (get-file-buffer folder) (find-file-noselect folder)))
  164.     (setq newbuf (current-buffer))
  165.     (if (not (eq major-mode 'vm-mode))
  166.     (vm-mode))
  167.     (if (null vm-message-pointer)
  168.     (error "No messages in folder %s" folder))
  169.     (save-excursion
  170.       (save-window-excursion
  171.     (save-window-excursion
  172.       (vm-summarize))
  173.     (switch-to-buffer vm-summary-buffer)
  174.     (setq sumbuf (current-buffer))
  175.     (delete-other-windows)
  176.     (set-buffer b)
  177.     (unwind-protect
  178.         (let ((prefix-arg prefix-argument)
  179.           (vm-mail-buffer newbuf))
  180.           (command-execute 'vm-yank-message))
  181.       (bury-buffer newbuf)
  182.       (bury-buffer sumbuf))))))
  183.  
  184. (defun vm-yank-message (message &optional prefix)
  185.   "Yank message number N into the current buffer at point.
  186. When called interactively N is always read from the minibuffer.  When
  187. called non-interactively the first argument is expected to be a message
  188. struct.
  189.  
  190. This command is meant to be used in VM created Mail mode buffers; the
  191. yanked message comes from the mail buffer containing the message you
  192. are replying to, forwarding, or invoked VM's mail command from.
  193.  
  194. All message headers are yanked along with the text.  Point is left
  195. before the inserted text, the mark after.  Any hook functions bound to
  196. mail-yank-hooks are run, aftert inserting the text and setting point
  197. and mark.
  198.  
  199. Prefix arg means to ignore mail-yank-hooks, don't set the mark, prepend the
  200. value of vm-included-text-prefix to every yanked line, and don't yank any
  201. headers other than those specified in vm-visible-headers/vm-invisible-headers."
  202.   (interactive
  203.    (list
  204.    ;; What we really want for the first argument is a message struct,
  205.    ;; but if called interactively, we let the user type in a message
  206.    ;; number instead.
  207.     (let (mp default (result 0) prompt)
  208.       (save-excursion
  209.     (vm-select-folder-buffer)
  210.     (setq default (and vm-message-pointer
  211.                (vm-number-of (car vm-message-pointer)))
  212.           prompt (if default
  213.              (format "Yank message number: (default %s) "
  214.                  default)
  215.                "Yank message number: "))
  216.     (while (zerop result)
  217.       (setq result (read-string prompt))
  218.       (and (string= result "") default (setq result default))
  219.       (setq result (string-to-int result)))
  220.     (if (null (setq mp (nthcdr (1- result) vm-message-list)))
  221.         (error "No such message.")))
  222.       (car mp))
  223.     current-prefix-arg ))
  224.   (if (not (bufferp vm-mail-buffer))
  225.       (error "This is not a VM Mail mode buffer."))
  226.   (if (null (buffer-name vm-mail-buffer))
  227.       (error "The mail buffer containing message %d has been killed."
  228.          (vm-number-of message)))
  229.   (let ((b (current-buffer)) (start (point)) mp end)
  230.     (save-restriction
  231.       (widen)
  232.       (save-excursion
  233.     (set-buffer (marker-buffer (vm-start-of message)))
  234.     (save-restriction
  235.       (widen)
  236.       (append-to-buffer b (if prefix
  237.                   (vm-vheaders-of message)
  238.                 (vm-start-of message))
  239.                 (vm-text-end-of message))
  240.       (setq end (vm-marker (+ start (- (vm-text-end-of message)
  241.                        (if prefix
  242.                            (vm-vheaders-of message)
  243.                          (vm-start-of message)))) b))))
  244.       (if prefix
  245.       (save-excursion
  246.         (while (and (< (point) end) (re-search-forward "^" end t))
  247.           (replace-match vm-included-text-prefix t t)
  248.           (forward-line)))
  249.     ;; Delete UNIX From or MMDF ^A^A^A^A line
  250.     (delete-region (point) (progn (forward-line) (point)))
  251.     (push-mark end)
  252.     (if mail-yank-hooks
  253.         (run-hooks 'mail-yank-hooks)
  254.       (vm-mail-yank-default message))))))
  255.  
  256. (defun vm-mail-send-and-exit (arg)
  257.   "Just like mail-send-and-exit except that VM flags the appropriate message(s)
  258. as having been replied to, if appropriate."
  259.   (interactive "P")
  260.   (let ((reply-buf (current-buffer)))
  261.     (mail-send-and-exit arg)
  262.     (save-excursion
  263.       (set-buffer reply-buf)
  264.       (cond ((eq vm-system-state 'replying)
  265.          (vm-mark-replied))
  266.         ((eq vm-system-state 'forwarding)
  267.          (vm-mark-forwarded)))
  268.       (vm-rename-current-mail-buffer)
  269.       ;; keep this buffer if the user demands it
  270.       (if (memq (current-buffer) vm-kept-mail-buffers)
  271.       (setq vm-kept-mail-buffers
  272.         (delq (current-buffer) vm-kept-mail-buffers)))
  273.       (setq vm-kept-mail-buffers (cons (current-buffer) vm-kept-mail-buffers))
  274.       (if (not (eq vm-keep-sent-messages t))
  275.       (let ((extras (nthcdr (or vm-keep-sent-messages 0) vm-kept-mail-buffers)))
  276.         (mapcar (function (lambda (b) (and (buffer-name b) (kill-buffer b)))) extras)
  277.         (and vm-kept-mail-buffers extras
  278.          (setcdr (memq (car extras) vm-kept-mail-buffers) nil)))))))
  279.  
  280. (defun vm-mail-send ()
  281.   "Just like mail-send except that VM flags the appropriate message(s)
  282. as having been replied to, if appropriate."
  283.   (interactive)
  284.   (mail-send)
  285.   (vm-rename-current-mail-buffer)
  286.   (cond ((eq vm-system-state 'replying)
  287.      (vm-mark-replied))
  288.     ((eq vm-system-state 'forwarding)
  289.      (vm-mark-forwarded))))
  290.  
  291. (defun vm-rename-current-mail-buffer ()
  292.   (if (not (string-match "^sent " (buffer-name)))
  293.       (let (prefix name n)
  294.     (if (not (= ?* (aref (buffer-name) 0)))
  295.         (setq prefix (format "sent %s" (buffer-name)))
  296.       (let (recipients)
  297.         (cond ((not (zerop (length (setq recipients (mail-fetch-field "To"))))))
  298.           ((not (zerop (length (setq recipients (mail-fetch-field "Cc"))))))
  299.           (t (setq recipient "the horse with no name")))
  300.         (setq prefix (format "sent mail to %s" recipients))))
  301.     (setq name prefix n 1)
  302.     (while (get-buffer name)
  303.       (setq name (format "%s<%d>" prefix n))
  304.       (vm-increment n))
  305.     (rename-buffer name))))
  306.  
  307. (defun vm-mark-replied ()
  308.   (save-excursion
  309.     (let ((mp vm-reply-list))
  310.       (while mp
  311.     (if (null (marker-buffer (vm-start-of (car mp))))
  312.         ()
  313.       (set-buffer (marker-buffer (vm-start-of (car mp))))
  314.       (cond ((and (memq (car mp) vm-message-list)
  315.               (null (vm-replied-flag (car mp))))
  316.          (vm-set-replied-flag (car mp) t))))
  317.     (setq mp (cdr mp)))
  318.       (vm-update-summary-and-mode-line))))
  319.  
  320. (defun vm-mark-forwarded ()
  321.   (save-excursion
  322.     (let ((mp vm-forward-list))
  323.       (while mp
  324.     (if (null (marker-buffer (vm-start-of (car mp))))
  325.         ()
  326.       (set-buffer (marker-buffer (vm-start-of (car mp))))
  327.       (cond ((and (memq (car mp) vm-message-list)
  328.               (null (vm-forwarded-flag (car mp))))
  329.          (vm-set-forwarded-flag (car mp) t))))
  330.     (setq mp (cdr mp)))
  331.       (vm-update-summary-and-mode-line))))
  332.  
  333. (defun vm-reply (count)
  334.   "Reply to the sender of the current message.
  335. Numeric prefix argument N mans to reply to the current message plus the
  336. next N-1 messages.  A negative N means reply to the current message and
  337. the previous N-1 messages. 
  338.  
  339. If invoked on marked messages (via vm-next-command-uses-marks),
  340. all marked messages will be replied to.
  341.  
  342. You will be placed into a standard Emacs Mail mode buffer to compose and
  343. send your message.  See the documentation for the function `mail' for
  344. more info.
  345.  
  346. Note that the normal binding of C-c C-y in the reply buffer is
  347. automatically changed to vm-yank-message during a reply.  This
  348. allows you to yank any message from the current folder into a
  349. reply.
  350.  
  351. Normal VM commands may be accessed in the reply buffer by prefixing them
  352. with C-c C-v."
  353.   (interactive "p")
  354.   (vm-follow-summary-cursor)
  355.   (vm-select-folder-buffer)
  356.   (vm-check-for-killed-summary)
  357.   (vm-error-if-folder-empty)
  358.   (vm-do-reply nil nil count))
  359.  
  360. (defun vm-reply-include-text (count)
  361.   "Reply to the sender (only) of the current message and include text
  362. from the message.  See the documentation for function vm-reply for details."
  363.   (interactive "p")
  364.   (vm-follow-summary-cursor)
  365.   (vm-select-folder-buffer)
  366.   (vm-check-for-killed-summary)
  367.   (vm-error-if-folder-empty)
  368.   (vm-do-reply nil t count))
  369.  
  370. (defun vm-followup (count)
  371.   "Reply to all recipients of the current message.
  372. See the documentation for the function vm-reply for details."
  373.   (interactive "p")
  374.   (vm-follow-summary-cursor)
  375.   (vm-select-folder-buffer)
  376.   (vm-check-for-killed-summary)
  377.   (vm-error-if-folder-empty)
  378.   (vm-do-reply t nil count))
  379.  
  380. (defun vm-followup-include-text (count)
  381.   "Reply to all recipients of the current message and include text from
  382. the message.  See the documentation for the function vm-reply for details."
  383.   (interactive "p")
  384.   (vm-follow-summary-cursor)
  385.   (vm-select-folder-buffer)
  386.   (vm-check-for-killed-summary)
  387.   (vm-error-if-folder-empty)
  388.   (vm-do-reply t t count))
  389.  
  390. (defun vm-forward-message ()
  391.   "Forward the current message to one or more third parties.
  392. You will be placed in a Mail mode buffer as is usual with replies, but you
  393. must fill in the To: and Subject: headers manually."
  394.   (interactive)
  395.   (vm-follow-summary-cursor)
  396.   (vm-select-folder-buffer)
  397.   (vm-check-for-killed-summary)
  398.   (vm-error-if-folder-empty)
  399.   (if (eq last-command 'vm-next-command-uses-marks)
  400.       (progn (setq this-command 'vm-next-command-uses-marks)
  401.          (command-execute 'vm-send-digest))
  402.     (let ((b (current-buffer))
  403.       (dir default-directory)
  404.       (mp vm-message-pointer)
  405.       start)
  406.       (save-restriction
  407.     (widen)
  408.     (vm-mail-internal
  409.      (format "forward of %s:%s" (buffer-name)
  410.          (vm-number-of (car vm-message-pointer)))
  411.      nil
  412.      (and vm-forwarding-subject-format
  413.           (vm-sprintf 'vm-forwarding-subject-format
  414.               (car mp))))
  415.     (use-local-map (copy-keymap (current-local-map)))
  416.     (local-set-key "\C-c\C-y" 'vm-yank-message)
  417.     (local-set-key "\C-cy" 'vm-yank-message-other-folder)
  418.     (local-set-key "\C-c\C-s" 'vm-mail-send)
  419.     (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  420.     (local-set-key "\C-c\C-v" vm-mode-map)
  421.     (make-local-variable 'vm-forward-list)
  422.     (setq vm-mail-buffer b
  423.           vm-system-state 'forwarding
  424.           vm-forward-list (list (car mp))
  425.           vm-message-pointer mp
  426.           default-directory dir)
  427.     (goto-char (point-max))
  428.     (insert "------- Start of forwarded message -------\n")
  429.     (setq start (point))
  430.     (insert-buffer-substring b
  431.                  (save-excursion
  432.                    (set-buffer b)
  433.                    (goto-char (vm-start-of (car mp)))
  434.                    (forward-line 1)
  435.                    (point))
  436.                  (vm-text-end-of (car mp)))
  437.     (if vm-rfc934-forwarding
  438.         (vm-rfc934-char-stuff-region start (point)))
  439.     (insert "------- End of forwarded message -------\n")
  440.     (goto-char (point-min))
  441.     (end-of-line)))))
  442.  
  443. (defun vm-mail ()
  444.   "Send a mail message from within VM, or from without."
  445.   (interactive)
  446.   (vm-session-initialization)
  447.   (vm-follow-summary-cursor)
  448.   (vm-select-folder-buffer)
  449.   (vm-check-for-killed-summary)
  450.   (let ((mail-buffer (if (memq major-mode '(vm-mode vm-virtual-mode))
  451.              (current-buffer))))
  452.     (vm-mail-internal)
  453.     (if (null mail-buffer)
  454.     ()
  455.       (use-local-map (copy-keymap (current-local-map)))
  456.       (local-set-key "\C-c\C-y" 'vm-yank-message)
  457.       (local-set-key "\C-c\C-v" vm-mode-map)
  458.       (setq vm-mail-buffer mail-buffer))
  459.     (local-set-key "\C-c\C-s" 'vm-mail-send)
  460.     (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  461.     (local-set-key "\C-cy" 'vm-yank-message-other-folder)))
  462.  
  463. (defun vm-resend-bounced-message ()
  464.   "Extract the original text from a bounced message and resend it.
  465. You will be placed in a Mail mode buffer with the extracted message and
  466. you can change the recipient address before resending the message."
  467.   (interactive)
  468.   (vm-follow-summary-cursor)
  469.   (vm-select-folder-buffer)
  470.   (vm-check-for-killed-summary)
  471.   (let ((b (current-buffer)) start
  472.     (dir default-directory)
  473.     (lim (vm-text-end-of (car vm-message-pointer))))
  474.       (save-restriction
  475.     (widen)
  476.     (save-excursion
  477.       (goto-char (vm-text-of (car vm-message-pointer)))
  478.       (let (case-fold-search)
  479.         ;; What a wonderful world it would be if mailers used the
  480.         ;; message encapsulation standard instead the following
  481.         ;; ad hockeries.
  482.         (or
  483.          ;; sendmail
  484.          (search-forward "----- Unsent message follows" lim t)
  485.          ;; smail 2.x
  486.          (search-forward "======= text of message follows" lim t)
  487.          ;; smail 3.x (?)
  488.          (search-forward "- Message text follows:" lim t)
  489.          ;; MMDF
  490.          (search-forward "Your message follows:\n" lim t)
  491.           (search-forward "    Your message begins as follows:\n" lim t)
  492.          ;; zmailer (?)
  493.          (search-forward "---  Original Message  ---" lim t)
  494.          ;; Grapevine
  495.          (search-forward "The text of your message was\n---" lim t)
  496.          (error "This does not appear to be a bounced message."))
  497.         (forward-line 1)
  498.         (setq start (point))))
  499.     (vm-mail-internal
  500.      (format "retry of %s:%s" (buffer-name)
  501.          (vm-number-of (car vm-message-pointer))))
  502.     (use-local-map (copy-keymap (current-local-map)))
  503.     (local-set-key "\C-c\C-y" 'vm-yank-message)
  504.     (local-set-key "\C-cy" 'vm-yank-message-other-folder)
  505.     (local-set-key "\C-c\C-s" 'vm-mail-send)
  506.     (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  507.     (local-set-key "\C-c\C-v" vm-mode-map)
  508.     (goto-char (point-min))
  509.     (insert-buffer-substring b start lim)
  510.     (delete-region (point) (point-max))
  511.     (goto-char (point-min))
  512.     ;; some mailers leave grot at the top of the message.
  513.     ;; trim it.
  514.     (while (not (looking-at vm-generic-header-regexp))
  515.       (delete-region (point) (progn (forward-line 1) (point))))
  516.     ;; delete all but pertinent headers
  517.     (while (looking-at vm-generic-header-regexp)
  518.       (let ((match-end-0 (match-end 0)))
  519.         (if (or
  520.          (looking-at "From:\\|To:\\|Cc:\\|Subject:\\|In-Reply-To\\|Resent-")
  521.          (looking-at "Newsgroups\\|References"))
  522.         (goto-char match-end-0)
  523.           (delete-region (point) match-end-0))))
  524.     (insert mail-header-separator)
  525.     (if (= (following-char) ?\n)
  526.         (forward-char 1)
  527.       (insert "\n"))
  528.     (setq vm-mail-buffer b
  529.           default-directory dir))))
  530.  
  531. (defun vm-resend-message (recipients)
  532.   "Resend the current message to someone else.
  533. You will be proompted in the minibuffer for the space or comma
  534. separated recipient list."
  535.   (interactive "sResend message to: ")
  536.   (vm-follow-summary-cursor)
  537.   (vm-select-folder-buffer)
  538.   (vm-check-for-killed-summary)
  539.   (vm-error-if-folder-empty)
  540.   (let ((vmp vm-message-pointer)
  541.     recipient-list t-buffer m-buffer
  542.     doomed-buffers
  543.     (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
  544.     (mail-header-seaprator ""))
  545.     (setq recipient-list (vm-parse recipients "[ \t,]*\\([^ ,\t]+\\)[ \t,]*"))
  546.     (unwind-protect
  547.     (progn
  548.       (vm-within-current-message-buffer
  549.        (vm-save-restriction
  550.         (widen)
  551.         (save-excursion
  552.           (setq m-buffer (generate-new-buffer "*VM resend*"))
  553.           (set-buffer m-buffer)
  554.           (make-local-variable 'vm-forward-list)
  555.           (setq vm-system-state 'forwarding
  556.             vm-forward-list (list (car vmp)))
  557.           (erase-buffer)
  558.           (insert-buffer-substring
  559.            (marker-buffer (vm-start-of (car vmp)))
  560.            (vm-start-of (car vmp))
  561.            (vm-text-end-of (car vmp))))))
  562.       (set-buffer m-buffer)
  563.       (goto-char (point-min))
  564.       ;; some mailers leave grot at the top of the message.
  565.       ;; trim it.
  566.       (while (not (looking-at vm-generic-header-regexp))
  567.         (delete-region (point) (progn (forward-line 1) (point))))
  568.       ;; indicate that this is a resend.  this should be all
  569.       ;; that's needed, as sendmail will generate the rest.
  570.       ;; But generate a Resent-From is the user is picky
  571.       ;; about the From header.
  572.       (if vm-mail-header-from
  573.           (insert "Resent-From: " vm-mail-header-from "\n"))
  574.       (insert "Resent-To: " (mapconcat 'identity recipient-list ", ") "\n")
  575.       ;; delete all but pertinent headers
  576.       (while (looking-at vm-generic-header-regexp)
  577.         (let ((match-end-0 (match-end 0)))
  578.           (if (not (looking-at "X-VM-\\|Status:"))
  579.           (goto-char match-end-0)
  580.         (delete-region (point) match-end-0))))
  581.       (setq t-buffer
  582.         (generate-new-buffer
  583.          (format "transcript of resend to %s" recipients)))
  584.       (goto-char (point-min))
  585.       (message "Sending...")
  586.       (apply 'call-process-region
  587.          (nconc (list (point-min) (point-max)
  588.                   sendmail-program
  589.                   nil t-buffer mail-interactive
  590.                   "-oi" "-oem")
  591.             (if mail-interactive
  592.                 (list "-v")
  593.               (list "-odb"))
  594.             recipient-list))
  595.       (vm-mark-forwarded)
  596.       (set-buffer t-buffer)
  597.       (if (zerop (buffer-size))
  598.           (message "Sent.")
  599.         (display-buffer t-buffer)
  600.         (bury-buffer t-buffer)
  601.         (setq t-buffer nil)
  602.         (message "")))
  603.       (and t-buffer (kill-buffer t-buffer))
  604.       (and m-buffer (kill-buffer m-buffer)))))
  605.  
  606. (defun vm-send-digest (&optional prefix)
  607.   "Send a digest of all messages in the current folder to recipients.
  608. You will be placed in a *mail* buffer as is usual with replies, but you
  609. must fill in the To: and Subject: headers manually.
  610.  
  611. Prefix arg means to insert a list of preamble lines at the beginning of
  612. the digest.  One line is generated for each message being digestified.
  613. The variable vm-digest-preamble-format determines the format of the
  614. preamble lines.
  615.  
  616. If invoked on marked messages (via vm-next-command-uses-marks),
  617. only marked messages will be put into the digest."
  618.   (interactive "P")
  619.   (vm-select-folder-buffer)
  620.   (vm-check-for-killed-summary)
  621.   (vm-error-if-folder-empty)
  622.   (let ((b (current-buffer))
  623.     (dir default-directory)
  624.     (mp vm-message-pointer)
  625.     ;; prefix arg doesn't have "normal" meaning here, so only call
  626.     ;; vm-select-marked-or-prefixed-messages if we're using marks.
  627.     (mlist (if (eq last-command 'vm-next-command-uses-marks)
  628.            (vm-select-marked-or-prefixed-messages 0)
  629.          vm-message-list))
  630.     start)
  631.     (save-restriction
  632.       (widen)
  633.       (vm-mail-internal (format "digest from %s" (buffer-name)))
  634.       (use-local-map (copy-keymap (current-local-map)))
  635.       (local-set-key "\C-c\C-y" 'vm-yank-message)
  636.       (local-set-key "\C-cy" 'vm-yank-message-other-folder)
  637.       (local-set-key "\C-c\C-s" 'vm-mail-send)
  638.       (local-set-key "\C-c\C-c" 'vm-mail-send-and-exit)
  639.       (local-set-key "\C-c\C-v" vm-mode-map)
  640.       (make-local-variable 'vm-forward-list)
  641.       (setq vm-mail-buffer b
  642.         vm-message-pointer mp
  643.         vm-system-state 'forwarding
  644.         vm-forward-list mlist
  645.         default-directory dir)
  646.       (goto-char (point-max))
  647.       (setq start (point)
  648.         mp mlist)
  649.       (message "Building digest...")
  650.       (while mp
  651.     (insert-buffer-substring (marker-buffer (vm-start-of (car mp)))
  652.                  (vm-start-of (car mp))
  653.                  (vm-end-of (car mp)))
  654.     (setq mp (cdr mp)))
  655.       (vm-digestify-region start (point))
  656.       (goto-char start)
  657.       (setq mp mlist)
  658.       (if prefix
  659.       (progn
  660.         (message "Building digest preamble...")
  661.         (while mp
  662.           (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n")
  663.           (if vm-digest-center-preamble
  664.           (progn
  665.             (forward-char -1)
  666.             (center-line)
  667.             (forward-char 1)))
  668.           (setq mp (cdr mp)))))
  669.       (goto-char (point-min))
  670.       (end-of-line)
  671.       (message "Building digest... done"))))
  672.  
  673. (defun vm-continue-composing-message (&optional not-picky)
  674.   "Find and select the most recently used mail composition buffer.
  675. If the selected buffer is already a Mail mode buffer then it is
  676. buried before beginning the search.  Non Mail mode buffers and
  677. unmodified Mail buffers are skipped.  Prefix arg means unmodified
  678. Mail mode buffers are not skipped.  If no suitable buffer is
  679. found, the current buffer remains selected."
  680.   (interactive "P")
  681.   (if (eq major-mode 'mail-mode)
  682.       (bury-buffer (current-buffer)))
  683.   (let ((b (vm-find-composition-buffer not-picky)))
  684.     (if (not (or (null b) (eq b (current-buffer))))
  685.     (switch-to-buffer b)
  686.       (message "No composition buffers found"))))
  687.  
  688. (defun vm-find-composition-buffer (&optional not-picky)
  689.   (let ((b-list (buffer-list)) choice alternate)
  690.     (save-excursion
  691.      (while b-list
  692.        (set-buffer (car b-list))
  693.        (if (eq major-mode 'mail-mode)
  694.        (if (buffer-modified-p)
  695.            (setq choice (current-buffer)
  696.              b-list nil)
  697.          (and not-picky (null alternate)
  698.           (setq alternate (current-buffer)))
  699.          (setq b-list (cdr b-list)))
  700.      (setq b-list (cdr b-list))))
  701.     (or choice alternate))))
  702.  
  703. (defun vm-mail-internal
  704.      (&optional buffer-name to subject in-reply-to cc references newsgroups)
  705.   (set-buffer (generate-new-buffer (or buffer-name "*VM-mail*")))
  706.   (auto-save-mode auto-save-default)
  707.   (mail-mode)
  708.   (switch-to-buffer (current-buffer))
  709.   (if (eq mail-aliases t)
  710.       (progn
  711.     (setq mail-aliases nil)
  712.     (if (file-exists-p "~/.mailrc")
  713.         (build-mail-aliases))))
  714.   (if (stringp vm-mail-header-from)
  715.       (insert "From: " vm-mail-header-from "\n"))
  716.   (insert "To: " (or to "") "\n")
  717.   (and cc (insert "Cc: " cc "\n"))
  718.   (insert "Subject: " (or subject "") "\n")
  719.   (and newsgroups (insert "Newsgroups: " newsgroups "\n"))
  720.   (and in-reply-to (insert "In-Reply-To: " in-reply-to "\n"))
  721.   (and references (insert "References: " references "\n"))
  722.   (if mail-default-reply-to
  723.       (insert "Reply-To: " mail-default-reply-to "\n"))
  724.   (if mail-self-blind
  725.       (insert "Bcc: " (user-login-name) "\n"))
  726.   (if mail-archive-file-name
  727.       (insert "FCC: " mail-archive-file-name "\n"))
  728.   (insert mail-header-separator "\n")
  729.   (save-excursion (vm-set-window-configuration 'composing-message))
  730.   (if to
  731.       (goto-char (point-max))
  732.     (mail-position-on-field "To"))
  733.   (run-hooks 'mail-setup-hook))
  734.  
  735. (require 'mail-utils)
  736. (require 'sendmail)
  737.